home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / Module source / pasmMod.txt < prev    next >
Encoding:
Text File  |  1995-11-30  |  25.4 KB  |  1,059 lines  |  [TEXT/MSET]
  1. (* *********
  2.  
  3. \                    PowerPC 601 Assembler
  4.  
  5. \ Copyright 1993-1994 Xan Gregg  All Rights Reserved
  6. \    Permission is granted for internal distribution by Creative Solutions, Inc.
  7.  
  8. \    Permission also granted for Mops distribution.  Mops mods made by
  9. \    Mike Hore.
  10.  
  11. This is a basic PowerPC 601 assembler.  It uses a Forth-like syntax,
  12. but the mnemonics and operand order is usually preserved.  The exception
  13. is the branching instructions, which will be seldom used anyway since
  14. words like IF, and WHILE, are available.  Often, duplicating identical
  15. parameters is not required, such as if the source and destination
  16. registers are the same.
  17.  
  18. Examples    Motorola Syntax                Forth Syntax
  19.             add.    r1, r1, r2            r1 r2    add.,
  20.             cmpi    cr1, r3, 25            cr1 r3 25 cmpi,
  21.             crnor    crb1, crb1, crb4    crb1 crb4 crnor,
  22.                             --ALSO--    cr0 bGT cr1 bLT crnor,
  23.             lfd        fr1, 20(r2)            fr1 20 r2 lfd,
  24.             mtspr    MQ, r3                MQ r3 mtspr,
  25.             blt        target                target lt bc,
  26.             blt-    target                hint target lt bc,
  27.             bdnzl    cr2, target            cr2 target dnz bcl,
  28.  
  29. Non-PowerPC instructions are not included.
  30.  
  31. ***** *)
  32.  
  33. decimal
  34.  
  35.  
  36. \ First, the Mops version of the utility words, and a few
  37. \  others we need as well:
  38.  
  39. : DeferrErr    true abort" DEFERRed word not set"  ;
  40.  
  41. : DEFER        ['] deferrErr  vect  ;
  42. : IS        postpone ->  ;    immediate
  43.  
  44. : TOKEN@    @abs  ;
  45. : TOKEN!    reloc!  ;
  46. : TOKEN,    reloc,  ;
  47.  
  48. : NOT    0=  ;
  49.  
  50. : SCALE ( val cnt -- val' )
  51.     dup 0< IF  negate >>  ELSE  <<  THEN  ;
  52.  
  53. : HEX#        postpone $   ;  immediate
  54.  
  55. : Lo2        $ 0000FFFF  postpone literal  postpone and  ;    immediate
  56. : Hi2        $ FFFF0000  postpone literal  postpone and  ;    immediate
  57. : Hi2Lo        16 >>  ;
  58.  
  59. : ERROR"    postpone abort"  ;    immediate
  60.  
  61. : EVAL        i >r  evaluate  r> -> i  ;    \ have to save & restore I till bug fixed
  62. : OFF        false swap !  ;
  63. : ON        true swap !   ;
  64. : BLWORD    Mword  ;
  65.  
  66. : TOKEN.FOR        state IF  postpone [']  ELSE  '  THEN  ;        immediate
  67.  
  68. : RANGE        within?  ;
  69.  
  70. : SIMM?     ( n -- n b )    \ is this a signed immediate (16 bit) value?
  71.     -32768 32767  within?  ;
  72. : UIMM?  ( n -- n b )
  73.     0 65535 within?  ;
  74.  
  75. : PSTRCPY ( addr1\addr2 -- )
  76.     over c@ 1+ cmove ;
  77.  
  78. : HOLD$        \ ( addr len -- )
  79.     dup --> hld
  80.     hld swap cmove  ;
  81.  
  82. : ALIGN4        \ pad with zero bytes till DP is 4-byte aligned
  83.     DP
  84.     4 reserve            \ just to ensure pad bytes are zero
  85.     3 +  $ fffffffc and  -> DP  ;
  86.  
  87. : #ALIGN4    \ ( n -- n' )
  88.     3 + $ fffffffc and  ;
  89.  
  90.  
  91. : code_align    PPC?
  92.                 IF        CDP 4 erase  CDP #align4  -> CDP
  93.                 ELSE    align4
  94.                 THEN  ;
  95.  
  96.  
  97. \ defer codeHere        ' here is codeHere 
  98. \ defer commaInstr     ' , is commaInstr
  99.  
  100. : codeHere        PPC? IF  CDP  ELSE  DP  THEN  ;
  101.  
  102. \ note: code, (defined in Base) already looks at PPC? and does the right thing.
  103.  
  104.  
  105.  
  106. 0 value   opInstr            \ instruction being assembled
  107.  
  108. : OR>INSTR  ( n -- )  opInstr or -> opInstr ;
  109.  
  110. : ScaleOR>INSTR  ( n\b -- )  scale or>instr ;
  111.  
  112. : >RaField  ( n -- )  16 scaleOr>Instr ;
  113. : >RbField  ( n -- )  11 scaleOr>Instr ;
  114. : >RcField  ( n -- )  6 scaleOr>Instr ;
  115. : >RdField  ( n -- )  21 scaleOr>Instr ;
  116. : >RsField  ( n -- )  21 scaleOr>Instr ;
  117. : >LField   ( n -- )  21 scaleOr>Instr ;
  118. : >TOField  ( n -- )  21 scaleOr>Instr ;
  119. : >SRField  ( n -- )  16 scaleOr>Instr ;
  120. : >SHField  ( n -- )  11 scaleOr>Instr ;
  121. : >NBField  ( n -- )  11 scaleOr>Instr ;
  122. : >MBField  ( n -- )  6 scaleOr>Instr ;
  123. : >MEField  ( n -- )  1 scaleOr>Instr ;
  124. : >DispField ( n -- ) Lo2 or>Instr ;
  125. : >ImmField  ( n -- ) Lo2 or>Instr ;
  126.  
  127. hex# fa970000 constant RegisterID
  128. hex# fa870000 constant FRegisterID
  129. hex# fa770000 constant CRegisterID
  130. hex# fa670000 constant CBRegisterID
  131. hex# fa570000 constant SPRegisterID
  132. hex# fa470000 constant ModifierID
  133. hex# fa370000 constant ConditionID
  134.  
  135. : MODIFIER  ( value -- | create a register constant)
  136.     ModifierID or constant ;
  137.  
  138. : MODIFIER?  ( [value] -- [value\true] | [false] )
  139.     depth 0 > IF dup Hi2 ModifierID = ELSE false THEN ;
  140.  
  141. : REGISTER  ( value -- | create a register constant)
  142.     RegisterID or constant ;
  143.  
  144. : REGISTER#  ( value -- n )
  145.     Lo2 ;
  146.  
  147. : REGISTER?  ( [value] -- [value\true] | [false] )
  148.     depth 0 > IF dup Hi2 RegisterID = ELSE false THEN ;
  149.  
  150. : REGISTER#?  ( [value] -- [value\true] | [false] )
  151.     register? dup if swap register# swap then  ;
  152.  
  153. : NEEDREGISTER  ( [value] -- )
  154.     register? not error" EXPECTED A REGISTER" ;
  155.     
  156. : NEEDREGISTER#  ( [value] -- n )
  157.     register#? not error" EXPECTED A REGISTER" ;
  158.     
  159. : DECLAREREGISTERS  ( -- )
  160.     32 0 DO
  161.         i 0 <# 2dup #s "  register R" hold$ 2drop #s #> eval
  162.     LOOP ;
  163.  
  164. : FREGISTER  ( value -- | create a register constant)
  165.     FRegisterID or constant ;
  166.  
  167. : FREGISTER?  ( [value] -- [value\true] | [false] )
  168.     depth 0 > IF dup Hi2 FRegisterID = ELSE false THEN ;
  169.  
  170. : FREGISTER#?  ( [value] -- [value\true] | [false] )
  171.     fregister? dup if swap register# swap then  ;
  172.  
  173. : NEEDFREGISTER  ( [value] -- )
  174.     fregister? not error" EXPECTED A FREGISTER" ;
  175.     
  176. : NEEDFREGISTER#  ( [value] -- )
  177.     fregister#? not error" EXPECTED A FREGISTER" ;
  178.     
  179. : DECLAREFREGISTERS  ( -- )
  180.     32 0 DO
  181.         i 0 <# 2dup #s "  fregister FR" hold$ 2drop #s #> eval
  182.     LOOP ;
  183.  
  184. : CREGISTER  ( value -- | create a register constant)
  185.     CRegisterID or constant ;
  186.  
  187. : CREGISTER?  ( [value] -- [value\true] | [false] )
  188.     depth 0 > IF dup Hi2 CRegisterID = ELSE false THEN ;
  189.  
  190. : CREGISTER#?  ( [value] -- [value\true] | [false] )
  191.     cregister? dup if swap register# swap then  ;
  192.  
  193. : NEEDCREGISTER  ( [value] -- )
  194.     cregister? not error" EXPECTED A CREGISTER" ;
  195.     
  196. : DECLARECREGISTERS  ( -- )
  197.     8 0 DO
  198.         i 0 <# 2dup #s "  cregister CR" hold$ 2drop #s #> eval
  199.     LOOP ;
  200.  
  201. : CBREGISTER  ( value -- | create a register constant)
  202.     CBRegisterID or constant ;
  203.  
  204. : CBREGISTER?  ( [value] -- [value\true] | [false] )
  205.     depth 0 > IF dup Hi2 CBRegisterID = ELSE false THEN ;
  206.  
  207. : CBREGISTER#?  ( [value] -- [value\true] | [false] )
  208.     cbregister? dup if swap register# swap then  ;
  209.  
  210. : NEEDCBREGISTER  ( [value] -- )
  211.     cbregister? not error" EXPECTED A CBREGISTER" ;
  212.     
  213. : DECLARECBREGISTERS  ( -- )
  214.     32 0 DO
  215.         i 0 <# 2dup #s "  cbregister CRB" hold$ 2drop #s #> eval
  216.     LOOP ;
  217.  
  218. : SPREGISTER  ( value -- | create a register constant)
  219.     dup 31 and 5 scale swap -5 scale or SPRegisterID or constant ;
  220.  
  221. : SPREGISTER?  ( [value] -- [value\true] | [false] )
  222.     depth 0 > IF dup Hi2 SPRegisterID = ELSE false THEN ;
  223.  
  224. : NEEDSPREGISTER  ( [value] -- )
  225.     spregister? not error" EXPECTED An SPREGISTER" ;
  226.     
  227. : CONDITION  ( value -- | create a condition constant)
  228.     conditionID or
  229.     constant ;
  230.  
  231. : CONDITION?  ( [value] -- [value\true] | [false] )
  232.     depth 0 > IF dup Hi2 conditionID = ELSE false THEN ;
  233.  
  234. : NEEDCONDITION  ( [value] -- )
  235.     condition? not error" EXPECTED A CONDITION" ;
  236.     
  237. : MODIFIERVALUE  ( value -- n )
  238.     Lo2 ;
  239.  
  240. : CONDITIONVALUE  ( value -- n )
  241.     Lo2 ;
  242.  
  243. \ branchHint is a one-shot set by 'hint' and cleared by the next branch instr.
  244. variable branchHint
  245. branchHint off
  246.  
  247. \ ASSEMBLER.WORDS
  248.  
  249. : hint    branchHint on ;
  250.  
  251. DeclareRegisters
  252. DeclareFRegisters
  253. DeclareCRegisters
  254. DeclareCBRegisters
  255.  
  256. 0 SPRegister    MQ
  257. 1 SPRegister    XER
  258. 4 SPRegister    RTCU
  259. 5 SPRegister    RTCL
  260. 6 SPRegister    DEC
  261. 8 SPRegister    LR
  262. 9 SPRegister    CTR
  263.  
  264. : bLT  ( [cr] -- crb )  CRegister#? not IF 0 THEN 4*    CBRegisterID or ;
  265. : bGT  ( [cr] -- crb )  CRegister#? not IF 0 THEN 4* 1+ CBRegisterID or ;
  266. : bEQ  ( [cr] -- crb )  CRegister#? not IF 0 THEN 4* 2+ CBRegisterID or ;
  267. : bSO  ( [cr] -- crb )  CRegister#? not IF 0 THEN 4* 3+ CBRegisterID or ;
  268.  
  269. create condArea 10 allot
  270.  
  271. : COND$        condArea count  ;
  272.  
  273.  
  274. : COND3  ( bit#\pos? -- )
  275.     blword condArea pstrcpy
  276.     IF  hex# 180  ELSE  hex# 080  THEN or
  277.     dup            0 <# cond$ hold$ "  condition " hold$ #s #> eval
  278.     hex# f7f and
  279.     dup ( 1+)    0 <# cond$ hold$ "  condition dnz" hold$ #s #> eval
  280.     hex# 040 or 0 <# cond$ hold$ "  condition dz" hold$ #s #> eval
  281.     ;
  282.  
  283. 0 1 cond3 lt
  284. 1 1 cond3 gt
  285. 2 1 cond3 eq
  286. 3 1 cond3 so
  287. 4 1 cond3 un
  288. 0 0 cond3 nl
  289. 1 0 cond3 ng
  290. 2 0 cond3 ne
  291. 3 0 cond3 ns
  292. 4 0 cond3 nu
  293. 0 0 cond3 ge
  294. 1 0 cond3 le
  295. hex# 200 condition dnz
  296. hex# 240 condition dz
  297. hex# 280 condition tr
  298.  
  299. 1 modifier LONG        \ for cmp instruction
  300. 0 modifier WD        \ for cmp instruction        ** note - can't use WORD
  301.  
  302. \ LOCAL.WORDS
  303.  
  304. \ GetDAB  ( dreg\[areg]\[breg]\tester -- | inserts D, A, and B regs into opInstr)
  305.     \ A and B are optional
  306.  
  307. : GetDAB  ( d a b ) { tester \ d a b -- }    \ inserts D, A, and B regs into opInstr)
  308. \ 0 0 0 locals| d a b tester |
  309.  
  310.     tester execute not error" expected a register"
  311.     -> b
  312.     tester execute not IF    \ 1 register: d,d,d
  313.         b -> a
  314.         a -> d
  315.     ELSE
  316.         -> a
  317.         tester execute IF    \ 3 registers: d,a,b
  318.             -> d
  319.         ELSE                \ 2 registers: d,d,a
  320.             a -> d
  321.         THEN
  322.     THEN
  323.     d >RdField a >RaField b >RbField ;
  324.     
  325. : GETRDAB  ( dreg\[areg]\[breg] -- )
  326.     token.for register#? getDAB ;
  327.  
  328. : GETFRDAB  ( dreg\[areg]\[breg] -- )
  329.     token.for fregister#? getDAB ;
  330.  
  331. : getCRBdab  ( dreg\[areg]\[breg] -- )
  332.     token.for cbregister#? getDAB ;
  333.  
  334. : ?SIMM  ( n -- )
  335.     simm? nip not error" EXPECTED A SIMM" ;
  336.  
  337. : ?UIMM  ( n -- )
  338.     0 65535 range nip not error" EXPECTED A UIMM" ;
  339.  
  340. \ GETDAIMM  ( dreg\[areg]\simm\tester -- | inserts D, and A regs and SIMM into opInstr)
  341.     \ A is optional
  342.  
  343. : GETDAIMM  ( d [a] ) { simm tester \ d a -- }
  344.  
  345. \    0 0 locals| d a tester simm |
  346.  
  347.     simm tester execute
  348.     register#? not error" expected a register"
  349.     -> a
  350.     register#? not IF a THEN -> d
  351.     d >RdField  a >RaField  simm >ImmField ;
  352.  
  353. : GETRDASIMM  ( dreg\[areg]\simm -- )
  354.     token.for ?simm GetDAImm ;
  355.  
  356. : GETRDAUIMM  ( dreg\[areg]\simm -- )
  357.     token.for ?uimm GetDAImm ;
  358.  
  359. : GETRDAIMM  ( dreg\[areg]\imm -- )
  360.     token.for drop GetDAImm ;
  361.  
  362. \ GETDA  ( dreg\[areg]\tester -- | inserts D and A regs into opInstr)
  363.     \ A is optional
  364. \    0 0 locals| d a tester |
  365.  
  366. : GETDA  ( d [a] ) { tester \ d a -- }
  367.  
  368.     tester execute not error" expected a register"
  369.     -> a
  370.     tester execute not IF a THEN -> d
  371.     d >RdField  a >RaField ;
  372.  
  373. : GETRDA  ( dreg\[areg] -- )
  374.     token.for register#? GetDA ;
  375.  
  376. : GETRASBIMM  ( [areg]\sreg\[breg]|[imm] -- )
  377.     register#? IF >RbField ELSE >ImmField THEN
  378.     needRegister# dup >R >RsField
  379.     register#? IF R> drop ELSE R> THEN >RaField ;
  380.  
  381. : GETRASB  ( [areg]\sreg\breg -- )
  382.     needRegister# >RbField
  383.     needRegister# dup >R >RsField
  384.     register#? IF R> drop ELSE R> THEN >RaField ;
  385.  
  386. : GETRASIMM  ( [areg]\sreg\imm -- )
  387.     dup ?uimm
  388.     >ImmField
  389.     needRegister# dup >R >RsField
  390.     register#? IF R> drop ELSE R> THEN >RaField ;
  391.  
  392. : GETCRLAB  ( [crReg]\[L]\areg\breg -- )
  393.     needRegister# >RbField
  394.     needRegister# >RaField
  395.     modifier? IF ModifierValue  >LField THEN
  396.     cregister#? if 23 ScaleOR>INSTR then ;
  397.  
  398. : GETCRLAIMM  ( [crReg]\[L]\areg\imm -- )
  399.     dup ?simm
  400.     >ImmField
  401.     needRegister# >RaField
  402.     modifier? IF ModifierValue  >LField THEN
  403.     cregister#? if 23 ScaleOR>INSTR then ;
  404.  
  405. : GETCRFAB  ( [crReg]\areg\breg -- )
  406.     needFRegister# >RbField
  407.     needFRegister# >RaField
  408.     cregister#? if 23 ScaleOR>INSTR then ;
  409.  
  410. : GETRAB  ( areg\breg -- )
  411.     needRegister# >RbField
  412.     needRegister# >RaField ;
  413.  
  414. : GETRAS  ( areg\[sreg] -- ) { \ s -- }
  415. \    needRegister# locals| S |
  416.     needRegister# -> s
  417.     s >RsField
  418.     register#? not IF s THEN >RaField ;
  419.  
  420. : GETFRDB  ( dfreg\[bfreg] -- ) { \ b -- }
  421. \    needFRegister# locals| B |
  422.     needFRegister# -> b
  423.     b >RbField
  424.     fregister#? not IF b THEN >RdField ;
  425.  
  426. : GetNull  ( -- )
  427.     ;
  428.  
  429. : GetRsab  ( [sreg]\areg\breg -- )
  430.     needRegister# >RbField
  431.     needRegister# dup >R >RaField
  432.     register#? IF R> drop ELSE R> THEN >RsField ;
  433.  
  434. : GetCRds  ( CRd\CRs -- )
  435.     needCRegister register# 18 ScaleOR>INSTR
  436.     needCRegister register# 23 ScaleOR>INSTR ;
  437.  
  438. : GetCRd  ( CRd -- )
  439.     needCRegister register# 23 ScaleOR>INSTR ;
  440.  
  441. : GetRd  ( Rd -- )
  442.     needRegister# >RdField ;
  443.  
  444. : GetRdSPR  ( Rd\SPR -- )
  445.     needSPRegister register# 11 ScaleOR>INSTR
  446.     needRegister# >RdField ;
  447.  
  448. : GetRdSR  ( Rd\SR -- )
  449.     >SRField
  450.     needRegister# >RdField ;
  451.  
  452. : GetRdb  ( [Rd]\Rb -- )
  453.     needRegister# dup >R >RbField
  454.     register#? IF R> drop ELSE R> THEN >RdField ;
  455.  
  456. : getCRMRs  ( CRM\Rs -- )
  457.     needRegister# >RsField
  458.     255 and 12 ScaleOR>INSTR ;        \ bug fixed 25-Aug-94 via msg from xg
  459.  
  460. : getCRBd  ( CRBd -- )
  461.     needCBRegister register# >RdField ;
  462.  
  463. : getFMFrb  ( FM\FRb -- )
  464.     needFRegister# >RbField
  465.     255 and 17 ScaleOR>INSTR ;
  466.  
  467. : getCRdBImm  ( CRd\Imm -- )
  468.     15 and 12 ScaleOR>INSTR
  469.     needCRegister register# 23 ScaleOR>INSTR ;
  470.  
  471. : GetRs  ( sreg -- )
  472.     needRegister# >RsField ;
  473.  
  474. : GetSPRRs  ( SPR\Rs -- )
  475.     needRegister# >RsField
  476.     needSPRegister register# 11 ScaleOR>INSTR ;
  477.  
  478. : getSRRs  ( SR\Rs -- )
  479.     needRegister# >RsField
  480.     15 and >SRField ;
  481.  
  482. : getRsb  ( [Rs]\Rb -- )
  483.     needRegister# dup >R >RbField
  484.     register#? IF R> drop ELSE R> THEN >RsField ;
  485.  
  486. : getRasSHMBME  ( [Ra]\Rs\SH\MB\ME -- )
  487.     31 and >MEField
  488.     31 and >MBField
  489.     31 and >SHField
  490.     needRegister# dup >R >RsField
  491.     register#? IF R> drop ELSE R> THEN >RaField ;
  492.  
  493. : getRasbMBME  ( [Ra]\Rs\Rb\MB\ME -- )
  494.     31 and >MEField
  495.     31 and >MBField
  496.     needRegister# >SHField
  497.     needRegister# dup >R >RsField
  498.     register#? IF R> drop ELSE R> THEN >RaField ;
  499.  
  500. : getRasSH  ( [Ra]\Rs\SH -- )
  501.     31 and >SHField
  502.     needRegister# dup >R >RsField
  503.     register#? IF R> drop ELSE R> THEN >RaField ;
  504.  
  505. : getRsaDisp  ( Rs\[disp\]Ra -- )
  506.     needRegister# >RaField
  507.     simm? if >DispField then
  508.     needRegister# >RsField ;
  509.  
  510. : getFRsRaDisp  ( FRs\[disp\]Ra -- )
  511.     needRegister# >RaField
  512.     simm? if >DispField then
  513.     needFRegister# >RsField ;
  514.  
  515. : getFRsRab  ( FRs\Ra\Rb -- )
  516.     needRegister# >RbField
  517.     needRegister# >RaField
  518.     needFRegister# >RsField ;
  519.  
  520. : getRsaNB  ( [Ra]\Rs\NB -- )
  521.     31 and >NBField
  522.     needRegister# dup >R >RaField
  523.     register#? IF R> drop ELSE R> THEN >RsField ;
  524.  
  525.  
  526. : getRb  ( Rb -- )
  527.     needRegister# >RbField ;
  528.  
  529. : getTORab  ( TO\Ra\Rb -- )
  530.     needRegister# >RbField
  531.     needRegister# >RaField
  532.     31 and >TOField ;
  533.  
  534. : getTORaSImm  ( TO\Ra\Simm -- )
  535.     dup ?simm >ImmField
  536.     needRegister# >RaField
  537.     31 and >TOField ;
  538.  
  539. : getFRdRaDisp  ( FRd\[disp\]Ra -- )
  540.     needRegister# >RaField
  541.     simm? if >DispField then
  542.     needFRegister# >RdField ;
  543.  
  544. : getFRdRab  ( FRd\Ra\Rb -- )
  545.     needRegister# >RbField
  546.     needRegister# >RaField
  547.     needFRegister# >RdField ;
  548.  
  549. : getRdaDisp  ( Rd\[disp\]Ra -- )
  550.     needRegister# >RaField
  551.     simm? if >DispField then
  552.     needRegister# >RdField ;
  553.  
  554. : getRdaNB  ( Rd\Ra\nb -- )
  555.     31 and >NBField
  556.     needRegister# >RaField
  557.     needRegister# >RdField ;
  558.  
  559. : getFRdacb  ( [FRd]\FRa\FRc\FRb -- )
  560.     needFRegister# >RbField
  561.     needFRegister# >RcField
  562.     needFRegister# dup >R >RaField
  563.     fregister#? IF R> drop ELSE R> THEN >RdField ;
  564.  
  565. : getFRdac  ( [FRd]\FRa\FRc -- )
  566.     needFRegister# >RcField
  567.     needFRegister# dup >R >RaField
  568.     fregister#? IF R> drop ELSE R> THEN >RdField ;
  569.  
  570.  
  571. : checkAddress  ( addr\numBits -- addr )
  572.     over 3 and error" INVALID ADDRESS - NOT MULTIPLE OF 4"
  573.     1 swap 1- scale dup negate swap 1- 
  574.     range not error" INVALID ADDRESS - OUT OF RANGE" ;
  575.  
  576. : ?hint    \ set the branch bit if requested by the one-shot
  577.     branchHint @ if
  578.         branchHint off
  579.         1 21 scaleOr>Instr
  580.     then ;
  581.  
  582. : getAbsAddr
  583.     26 checkAddress
  584. \    hex# 3FF,FFFC and or>Instr ?hint ;
  585.     hex# 3FFFFFC and or>Instr ?hint ;
  586.  
  587. : getRelAddr  ( addr -- )
  588.     codehere - getAbsAddr ;
  589.  
  590. : getBOBI  ( [crreg]\[cond] -- )
  591.     condition? IF
  592.         conditionValue 16 ScaleOr>Instr
  593.     ELSE
  594.         hex# 280 16 ScaleOr>Instr    \ branch always if no condition
  595.     THEN
  596.     cregister#? IF
  597.         18 ScaleOr>Instr
  598.     THEN ?hint ;
  599.  
  600. : getUncondBOBI    ( -- )
  601.     hex# 280 16 ScaleOr>Instr ;    \ branch always
  602.  
  603.  
  604. : getBOBIAddr  ( addr\[cond]\[cond] -- )
  605.     condition? IF
  606.         conditionValue 16 ScaleOr>Instr
  607.     ELSE
  608.         hex# 280 16 ScaleOr>Instr    \ branch always if no condition
  609.     THEN
  610.     opInstr 2 and not IF codehere - THEN
  611.     13 checkAddress hex# fffc and or>Instr
  612.     cregister#? IF
  613.         18 ScaleOr>Instr
  614.     THEN ?hint ;
  615.  
  616. \ -------------------------------------------------------
  617. : OP  ( asm instruction defining word )
  618. \    find dup -found >R
  619. \    create ( opcode1\opcode2 -- ) swap 26 scale or , R> token,
  620.  
  621.     Mword find NIF ." aauuggghhh!!" abort  THEN
  622.     >r
  623.     <builds  ( opcode1\opcode2 -- ) swap 26 scale or ,  r> token,
  624.  
  625.     does> ( pfa -- | lays down instruction )
  626.         dup @ -> opInstr
  627.         4+ token@ execute
  628.         opInstr code,  ;
  629.  
  630. create OPCODEArea 10 allot
  631. : OPCODE$    opcodeArea count  ;
  632.  
  633. create GETTERAREA 20 allot
  634. : GETTER$    getterArea count  ;
  635.  
  636. : DEFININGTEXT  ( n1 n2 -- 0 | called from inside <# #> )
  637. \ mh's note - we take care of converting the numbers to doubles here.
  638.  
  639.     0 swap  0
  640.     opcode$ hold$ BL hold getter$ hold$ "  OP " hold$ #S BL hold 2drop #s ;
  641.  
  642. \ : evaluate.string  ( addr -- )
  643. \    cr dup count type
  644. \    evaluate.string
  645. \    40 >col here 14 .r ;
  646.     
  647. : OPo.  ( opcode1\opcode2 -- super asm instruction defining word )
  648.     blword getterArea pstrcpy
  649.     blword opcodeArea pstrcpy
  650.     2* 2dup        <# " ,"        hold$ definingText #> eval
  651.     2dup 1+        <# " .,"    hold$ definingText #> eval
  652.     2dup 1024 + <# " o,"    hold$ definingText #> eval
  653.          1025 + <# " o.,"    hold$ definingText #> eval
  654.     ;
  655.  
  656. : OP.  ( opcode1\opcode2 -- super asm instruction defining word )
  657.     blword getterArea pstrcpy
  658.     blword opcodeArea pstrcpy
  659.     2* 2dup    <# " ,"   hold$ definingText #> eval
  660.          1+    <# " .,"  hold$ definingText #> eval
  661.     ;
  662.  
  663. \ ASSEMBLER.WORDS
  664.  
  665.  
  666. 31 266    OPo.    getRdab        add
  667. 31  10    OPo.    getRdab        addc
  668. 31 138    OPo.    getRdab        adde
  669. 14    0    OP        getRdaSimm    addi,
  670. 12    0    OP        getRdaSimm    addic,
  671. 13    0    OP        getRdaSimm    addic.,
  672. 15    0    OP        getRdaSimm    addis,
  673. 31 234    OPo.    getRda        addme
  674. 31 202    OPo.    getRda        addze
  675. 31  28    OP.        getRasb        and
  676. 31  60    OP.        getRasb        andc
  677. 28  0    OP        getRasImm    andi.,
  678. 29  0    OP        getRasImm    andis.,
  679.  
  680. ( ** branch instructions ** )
  681. 18    0    OP        getRelAddr    b,
  682. 18    2    OP        getAbsAddr    ba,
  683. 18    1    OP        getRelAddr    bl,
  684. 18    3    OP        getAbsAddr    bla,
  685. 16    0    OP        getBOBIAddr    bc,
  686. 16    2    OP        getBOBIAddr    bca,
  687. 16    1    OP        getBOBIAddr    bcl,
  688. 16    3    OP        getBOBIAddr    bcla,
  689. 19 1056    OP        getBOBI        bcctr,
  690. 19 1057    OP        getBOBI        bcctrl,
  691. 19    32    OP        getBOBI        bclr,
  692. 19    33    OP        getBOBI        bclrl,
  693. 19 1056    OP        getUncondBOBI    bctr,
  694. 19 1057    OP        getUncondBOBI    bctrl,
  695. 19    32    OP        getUncondBOBI    blr,
  696. 19    33    OP        getUncondBOBI    blrl,
  697.  
  698. 31  0    OP        getCrLAB    cmp,
  699. 11  0    OP        getCrLAImm    cmpi,
  700. 31  64    OP        getCrLAB    cmpl,
  701. 10  0    OP        getCrLAImm    cmpli,
  702. 31  26    OP.        getRas        cntlzw
  703. 19 514  OP        getCRBdab    crand,
  704. 19 258  OP        getCRBdab    crandc,
  705. 19 578  OP        getCRBdab    creqv,
  706. 19 450  OP        getCRBdab    crnand,
  707. 19  66  OP        getCRBdab    crnor,
  708. 19 898  OP        getCRBdab    cror,
  709. 19 834  OP        getCRBdab    crorc,
  710. 19 386  OP        getCRBdab    crxor,
  711. 31 172    OP        getRab        dcbf,
  712. 31 940    OP        getRab        dcbi,
  713. 31 108    OP        getRab        dcbst,
  714. 31 556    OP        getRab        dcbt,
  715. 31 492    OP        getRab        dcbtst,
  716. 31 2028    OP        getRab        dcbz,
  717. 31 491    OPo.    getRdab        divw
  718. 31 459    OPo.    getRdab        divwu
  719. 31 620    OP        getRdab        eciwx,
  720. 31 876    OP        getRdab        ecowx,
  721. 31 1708    OP        getNull        eieio,
  722. 31 284    OP.        getRasb        eqv
  723. 31 954    OP.        getRas        extsb
  724. 31 922    OP.        getRas        extsh
  725.  
  726. 63 264    OP.        getFRdb        fabs
  727. 63  21    OP.        getFRdab    fadd
  728. 59  21    OP.        getFRdab    fadds
  729. 63  64    OP        getCRFab    fcmpo,
  730. 63  0    OP        getCRFab    fcmpu,
  731. 63  14    OP.        getFRdb        fctiw
  732. 63  15    OP.        getFRdb        fctiwz
  733. 63  18    OP.        getFRdab    fdiv
  734. 59  18    OP.        getFRdab    fdivs
  735. 63  29    OP.        getFRdacb    fmadd
  736. 59  29    OP.        getFRdacb    fmadds
  737. 63  72    OP.        getFRdb        fmr
  738. 59  28    OP.        getFRdacb    fmsub
  739. 59  28    OP.        getFRdacb    fmsubs
  740. 63  25    OP.        getFRdac    fmul
  741. 59  25    OP.        getFRdac    fmuls
  742. 63  136    OP.        getFRdb        fnabs
  743. 63  40    OP.        getFRdb        fneg
  744. 63  31    OP.        getFRdacb    fnmadd
  745. 59  31    OP.        getFRdacb    fnmadds
  746. 63  30    OP.        getFRdacb    fnmsub
  747. 59  30    OP.        getFRdacb    fnmsubs
  748. 63  12    OP.        getFRdb        frsp
  749. 63  20    OP.        getFRdab    fsub
  750. 59  20    OP.        getFRdab    fsubs
  751.  
  752. 31 1964 OP        getRab        icbi,
  753. 19 300    OP        getNull        isync,
  754. 34  0    OP        getRdaDisp    lbz,
  755. 35  0    OP        getRdaDisp    lbzu,
  756. 31 238    OP        getRdab        lbzux,
  757. 31 174    OP        getRdab        lbzx,
  758. 50  0    OP        getFRdRaDisp lfd,
  759. 51  0    OP        getFRdRaDisp lfdu,
  760. 31 1262    OP        getFRdRab    lfdux,
  761. 31 1198    OP        getFRdRab    lfdx,
  762. 48  0    OP        getFRdRaDisp lfs,
  763. 49  0    OP        getFRdRaDisp lfsu,
  764. 31 1134    OP        getFRdRab    lfsux,
  765. 31 1070    OP        getFRdRab    lfsx,
  766. 31 1198    OP        getFRdRab    lfdx,
  767. 42  0    OP        getRdaDisp    lha,
  768. 43  0    OP        getRdaDisp    lhau,
  769. 31 750    OP        getRdab        lhaux,
  770. 31 686    OP        getRdab        lhax,
  771. 31 1580    OP        getRdab        lhbrx,
  772. 40  0    OP        getRdaDisp    lhz,
  773. 41  0    OP        getRdaDisp    lhzu,
  774. 31 622    OP        getRdab        lhzux,
  775. 31 558    OP        getRdab        lhzx,
  776. 46  0    OP        getRdaDisp    lmw,
  777. 31 1194    OP        getRdaNb    lswi,
  778. 31 1066    OP        getRdab        lswx,
  779. 31  40    OP        getRdab        lwarx,
  780. 31 1068    OP        getRdab        lwbrx,
  781. 32  0    OP        getRdaDisp    lwz,
  782. 33  0    OP        getRdaDisp    lwzu,
  783. 31 110    OP        getRdab        lwzux,
  784. 31  46    OP        getRdab        lwzx,
  785.  
  786. 19  0    OP        getCRds        mcrf,
  787. 63 128    OP        getCRds        mcrfs,
  788. 31 1024    OP        getCRd        mcrxr,
  789. 31  38    OP        getRd        mfcr,
  790. 63  583    OP.        getRd        mffs
  791. 31  166    OP        getRd        mfmsr,
  792. 31  678    OP        getRdSPR    mfspr,
  793. 31 1190    OP        getRdSR        mfsr,
  794. 31 1318    OP        getRdb        mfsrin,
  795. 31  288    OP        getCRMRs    mtcrf,
  796. 63  70    OP.        getCRBd        mtfsb0
  797. 63  38    OP.        getCRBd        mtfsb1
  798. 31  711 OP.        getFMFrb    mtfsf
  799. 63  134    OP.        getCRdBImm    mtfsfi
  800. 31  292    OP        getRs        mtmsr,
  801. 31  934    OP        getSPRRs    mtspr,
  802. 31  420    OP        getSRRs        mtsr,
  803. 31    484    OP        getRsb        mtsrin,
  804. 31   75    OP.        getRdab        mulhw
  805. 31   11    OP.        getRdab        mulhwu
  806. 31  235    OPo.    getRdab        mullw
  807. 7    0    OP        getRdaSImm    mulli,
  808. 31  476    OP.        getRasb        nand
  809. 31  104    OPo.    getRda        neg
  810. 31  124    OP.        getRasb        nor
  811. 31  444    OP.        getRasb        or
  812. 31  412    OP.        getRasb        orc
  813. 24    0    OP        getRasImm    ori,
  814. 25    0    OP        getRasImm    oris,
  815. 19  100    OP        getNull        rfi,
  816. 20    0    OP.        getRasSHMBME rlwimi
  817. 21    0    OP.        getRasSHMBME rlwinm
  818. 23    0    OP.        getRasbMBME  rlwnm
  819. 17    2    OP        getNull        sc,
  820.  
  821. 31   24    OP.        getRasb        slw
  822. \ 31 794OP.        getRasb        srad
  823. 31  792    OP.        getRasb        sraw
  824. 31  824    OP.        getRasSH    srawi
  825. \ 31 539OP.        getRasb        srd
  826. 31  536    OP.        getRasb        srw
  827. 38    0    OP        getRsaDisp    stb,
  828. 39    0    OP        getRsaDisp    stbu,
  829. 31  494 OP        getRsab        stbux,
  830. 31  430 OP        getRsab        stbx,
  831. 54    0    OP        getFRsRaDisp stfd,
  832. 55    0    OP        getFRsRaDisp stfdu,
  833. 31 1518    OP        getFRsRab    stfdux,
  834. 31 1454    OP        getFRsRab    stfdx,
  835. 52    0    OP        getFRsRaDisp stfs,
  836. 53    0    OP        getFRsRaDisp stfsu,
  837. 31 1390    OP        getFRsRab    stfsux,
  838. 31 1326    OP        getFRsRab    stfsx,
  839. 44    0    OP        getRsaDisp    sth,
  840. 31 1836    OP        getRsab        sthbrx,
  841. 45    0    OP        getRsaDisp    sthu,
  842. 31  878    OP        getRsab        sthux,
  843. 31  814    OP        getRsab        sthx,
  844. 47    0    OP        getRsaDisp    stmw,
  845. 31 1450    OP        getRsaNB    stswi,
  846. 31 1322    OP        getRsab        stswx,
  847. 36    0    OP        getRsaDisp    stw,
  848. 31 1324    OP        getRsab        stwbrx,
  849. 31  301    OP        getRsab        stwcx.,
  850. 37    0    OP        getRsaDisp    stwu,
  851. 31  366    OP        getRsab        stwux,
  852. 31  302    OP        getRsab        stwx,
  853. 31   40    OPo.    getRdab        subf
  854. 31    8    OPo.    getRdab        subfc
  855. 31    136    OPo.    getRdab        subfe
  856. 08    0    OP        getRdaSImm    subfic,
  857. 31    232    OPo.    getRda        subfme
  858. 31    200    OPo.    getRda        subfze
  859. 31 1196    OP        getNull        sync,
  860. 31  612    OP        getRb        tlbie,
  861. 31    8    OP        getTORab    tw,
  862. 03    0    OP        getTORaSImm    twi,
  863. 31  316    OP.        getRasb        xor
  864. 26    0    OP        getRasImm    xori,
  865. 27    0    OP        getRasImm    xoris,
  866.  
  867. \  Assembler Macro Definitions
  868.  
  869. \ Branching macros
  870.  
  871. : bcPatch  ( instr addr\dest addr )
  872.     over - 13 checkAddress 
  873.     hex# 0000FFFC and over @ hex# FFFF0003 and or swap ! ;
  874.  
  875. : bPatch  ( instr addr\dest addr )
  876.     over - 24 checkAddress 
  877.     hex# 03FFFFFC and over @ hex# FC000003 and or swap ! ;
  878.  
  879. : invertCondition  ( condition -- condition' )
  880.     dup hex# 200 and 0= IF    \ make sure it uses conditions
  881.         hex# 100 xor        \ flip BO[1]
  882.     THEN ;
  883.     
  884. : if,  ( condition -- addr\2 )
  885.     invertCondition codehere swap bc,
  886.     codehere 4- 2 ;
  887.  
  888. : else,   ( addr\2 -- addr\3 )
  889.     2 ?pairs codehere 4+ bcPatch
  890.     codehere b,
  891.     codehere 4- 3 ;
  892.     
  893. : then,  ( [addr\2] or [addr\3] -- )
  894.     dup 3 = IF
  895.         3 ?pairs codehere bpatch
  896.     ELSE
  897.         2 ?pairs codehere bcPatch
  898.     THEN ;
  899.  
  900. : begin,  ( -- addr\1 )
  901.     codehere 1 ;
  902.  
  903. : while,  ( condition -- addr\4 )
  904.     if, 2+ ;
  905.  
  906. : bcBackwhiles  ( [addr\4]* -- )
  907.     begin
  908.         dup 4 =
  909.     while
  910.         drop codehere 4+ bcPatch
  911.     repeat ;
  912.  
  913. : again,  ( addr\1[\addr\4]* -- )
  914.     bcBackwhiles
  915.     1 ?pairs
  916.     b, ;
  917.     
  918. : repeat,  ( addr\1[\addr\4]* -- )
  919.     again, ;
  920.  
  921. : until,  ( addr\1[\addr\4]*\condition -- )
  922.     >R bcBackwhiles
  923.     1 ?pairs
  924.     R> invertCondition bc, ;
  925.  
  926. \ these are simplified mnemonics from PowerPC manual
  927.  
  928. : nop,  ( -- )  r0 r0 r0 ori, ;
  929.  
  930. : li,        ( rA\SIMM -- | load immediate )                r0 swap addi, ;
  931. : lis,        ( rA\SIMM -- | load immediate shifted )        r0 swap addis, ;
  932. : lli,        ( rA\SLIMM -- | load long immediate )
  933.     dup 0=
  934.     IF    li,
  935.      ELSE
  936.         2dup extend dup  \ rA\SLIMM\rA\simm\simm
  937.         IF    li,
  938.             dup Hi2Lo swap hex# 8000 and IF \ sign bit set in lo 16 bits?
  939.             1+ Lo2
  940.         THEN
  941.         dup IF extend addis, ELSE 2drop THEN
  942.         ELSE        \ lo half is 0
  943.             2drop Hi2Lo extend lis,
  944.         THEN
  945.     THEN ;
  946.  
  947. (* ***
  948. old versions:
  949.  
  950. : li,  ( rA\SIMM -- | load immediate )  r0 swap addi, ;
  951. : lis,  ( rA\SIMM -- | load immediate shifted )  r0 swap addis, ;
  952. : lli,  ( rA\SLIMM -- | load long immediate )
  953.         2dup extend li,
  954.         dup Hi2Lo swap hex# 8000 and IF    \ sign bit set in lo 16 bits?
  955.             1+ Lo2
  956.         THEN
  957.         ?dup IF extend addis, ELSE drop THEN ;
  958.  
  959. *** *)
  960.  
  961. : lui,  ( rA\SIMM -- | load immediate )  lli, ;
  962. : la,  ( rD\SIMM\rA -- | load address ) swap addi, ;
  963. : move,  ( rA\rS -- )  dup or, ;
  964. : move.,  ( rA\rS -- )  dup or., ;
  965. : not,  ( rA\rS -- )  dup nor, ;
  966. : not.,  ( rA\rS -- )  dup nor., ;
  967. : subi,  ( rA\SIMM -- ) negate addi, ;
  968. : slwi,  ( rA\rS\n -- ) 0 over 31 swap - rlwinm, ;
  969. : srwi,  ( rA\rS\n -- ) 32 over - swap 31 rlwimi, ;
  970.  
  971. : mtlr,  ( rA -- ) lr swap mtspr, ;
  972. : mflr,  ( rA -- ) lr mfspr, ;
  973. : mtctr,  ( rA -- ) ctr swap mtspr, ;
  974. : mfctr,  ( rA -- ) ctr mfspr, ;
  975. : clr,  ( rA -- ) dup dup subf, ;
  976.  
  977. \ Some Forth macros
  978.  
  979. : rOSSP  r1 ;    \ Operating system stack pointer
  980. : rTOC  r2 ;    \ table of contents pointer
  981. : rTOS  r13 ;    \ top of data stack value
  982. : rDSP  r14 ;    \ data stack pointer
  983. : rRSP  r15 ;     \ return stack pointer
  984. : rUP   r16 ;    \ user area pointer
  985. : rLFP  r17 ;    \ local frame pointer
  986. : rCBP    r18 ;    \ code base pointer
  987. : rDBP    r19 ;    \ data base pointer
  988. : rDoLimit r20 ;
  989. : rDoIndex r21 ;
  990.  
  991. \ Note: R11, R12, CR6, & CR7 are designated as scratch registers by Apple
  992.  
  993. : rX    r11 ;
  994. : rY    r12 ;
  995. : crX    cr6 ;
  996. : crY    cr7 ;
  997.  
  998. \ r0 is also scratch but must be used carefully as it is special in some
  999. \  instructions
  1000.  
  1001. : put,  ( reg -- )    rtos swap move, ;
  1002. : pushtos,  ( -- )  rtos -4 rdsp stwu,  ;
  1003. : push,  ( reg -- )  pushtos,  put, ;
  1004.  
  1005. : get,  ( reg -- )    rtos move, ;
  1006. : poptos,  ( -- )  rtos 0 rdsp lwz, rdsp 4 addi, ;
  1007. : pop,  ( reg -- )  get,  poptos,  ;
  1008.  
  1009. : tst,  ( reg -- )  0 cmpi, ;
  1010.  
  1011. : rts,  ( -- )  bclr, ;
  1012. : next,  ( address interpreter )
  1013.      rts, ;
  1014.  
  1015.  
  1016. decimal
  1017.  
  1018. false    value    pasm_done?
  1019.  
  1020.  
  1021. : FIND_IN_PASM    \ ( s255 -- cfa true | -- s255 false )
  1022.     find: pasmMod  ;
  1023.  
  1024.  
  1025. : ENTERCODE        \ begin assembly outside of a colon definition
  1026.     lock: pasmMod
  1027.     ['] find_in_pasm  -> extraFind    \ look up words in pasm first.  Exclude
  1028.                                     \  locals and class stuff for the duration
  1029.     false -> pasm_done?
  1030.     code_align
  1031. ;
  1032.  
  1033.  
  1034. \ :PPC_CODE begins a code definition.  We set up a header specifying
  1035. \ no named parms/locals and 2 results.  This means that the top 2 stack
  1036. \ cells will be in r4 and r3 on both entry and exit, which keeps things
  1037. \ simple.
  1038.  
  1039. : :PPC_CODE
  1040.     ppc_header
  1041.     $ BE00 codeW,            \ handler code for PPC colon defns    
  1042.     $ 0200 codeW,            \ no named parms/locals, 2 results
  1043.     entercode
  1044.     BEGIN
  1045.         topfile -> source-ID  (Frefill)  IF  interpret  THEN
  1046.         pasm_done?
  1047.     UNTIL  ;
  1048.  
  1049.  
  1050. : ;PPC_CODE
  1051.     0 -> extraFind
  1052.     unlock: pasmMod
  1053.     true -> pasm_done?
  1054.     ?exec  reveal
  1055. ;
  1056.  
  1057.  
  1058. // disAsm
  1059.